home *** CD-ROM | disk | FTP | other *** search
/ Cream of the Crop 26 / Cream of the Crop 26.iso / program / pa32v315.zip / TEST30.BAS < prev    next >
BASIC Source File  |  1996-02-20  |  11KB  |  397 lines
  1. ' Tuomas Salste
  2. ' File name parsing library
  3. ' Included as an example for Project Analyzer
  4. ' These functions will not necessarily work
  5.  
  6. Option Explicit
  7. DefInt A-Z
  8.  
  9. Type FilenameType
  10.    drive As String '* 8
  11.    Path As String '* 63
  12.    Filename As String '* 12
  13.    Basename As String '* 8
  14.    Extension As String '* 3
  15. End Type
  16.  
  17. Global FName As FilenameType
  18.  
  19. Global Const DRIVE_FLOPPY = 2
  20. Global Const DRIVE_FIXED = 1
  21. Global Const DRIVE_NETWORK = 0
  22.  
  23. ' DiskSpaceFree function uses this in SETUPKIT.DLL
  24. ' Not needed if not used
  25. Declare Function DiskSpaceFree_DLL Lib "SETUPKIT.DLL" Alias "DiskSpaceFree" () As Long
  26.  
  27. Function AbsPath (ByVal BaseDir As String, ByVal Path As String) As String
  28. ' Gives Absolute Path from Relative Path
  29.  
  30. Dim GivenPath As FilenameType
  31. Dim Result As Integer
  32. Result = FileNameSplit(Path, GivenPath)
  33. If GivenPath.drive <> "" Then
  34.     On Error Resume Next
  35.     BaseDir = CurDir(GivenPath.drive)
  36.     If Err Then
  37.     BaseDir = GivenPath.drive + "\"
  38.     End If
  39.     On Error GoTo 0
  40. Else
  41.     If BaseDir = "" Then
  42.     BaseDir = CurDir
  43.     End If
  44. End If
  45.  
  46. Dim nDir As String
  47. Do While Path <> ""
  48.     nDir = NextDir(Path)
  49.     Select Case nDir
  50.     Case ".."
  51.         Dim BackPath As FilenameType
  52.         Result = FileNameSplit(BaseDir, BackPath)
  53.         BaseDir = BackPath.Path
  54.     Case "."
  55.     Case "\"
  56.         BaseDir = DriveOnly(BaseDir) + "\"
  57.     Case Else
  58.         BaseDir = PathNameWithSlash(BaseDir) & nDir
  59.     End Select
  60. Loop
  61. AbsPath = UCase(BaseDir)
  62.  
  63. End Function
  64.  
  65. Function Basenameonly (ByVal FileSpec As String) As String
  66. ' Returns the base name of a filespec
  67. ' FileSpec can be a directory name too
  68.  
  69. Dim Filename As FilenameType
  70. Dim Result As Integer
  71. Result = FileNameSplit(FileSpec, Filename)
  72. Basenameonly = Filename.Basename
  73.  
  74. End Function
  75.  
  76. Function ChangeFilenameExtension (ByVal OldFilename As String, ByVal NewExtension As String) As String
  77. ' Example:
  78. ' ChangeFilenameExtension("AUTOEXEC.BAT", "TMP")
  79. ' results in "AUTOEXEC.TMP"
  80. ' Returns "" in error
  81.  
  82. Dim File As FilenameType
  83. If FileNameSplit(OldFilename, File) Then
  84.     File.Extension = NewExtension
  85.     File.Filename = File.Basename & "." & File.Extension
  86.     ChangeFilenameExtension = FileNameExpand(File)
  87. Else
  88.     Exit Function
  89. End If
  90.  
  91. End Function
  92.  
  93. '------------------------------------------------
  94. ' Get the disk space free for the current drive
  95. '------------------------------------------------
  96. Function DiskSpaceFree (drive As String) As Long
  97.  
  98. Dim OldDrive As String
  99. OldDrive = DriveOnly(CurDir)
  100.  
  101. On Error Resume Next
  102. ChDrive drive
  103. If Err = 0 Then
  104.     DiskSpaceFree = DiskSpaceFree_DLL()
  105. End If
  106. ChDrive OldDrive
  107.  
  108. End Function
  109.  
  110. Function DriveOnly (ByVal FileSpec As String) As String
  111. ' Returns the drive "D:"
  112.  
  113. Dim File As FilenameType
  114. If FileNameSplit(FileSpec, File) Then
  115.     DriveOnly = File.drive
  116. End If
  117.  
  118. End Function
  119.  
  120. Function DriveType (ByVal DriveLetter As String, DriveListBox As DriveListBox) As Integer
  121. ' Returns the type of a drive
  122. ' Type is one of the following:
  123. ' DRIVE_FLOPPY, DRIVE_FIXED, DRIVE_NETWORK
  124.  
  125. Dim i As Integer
  126. For i = 0 To DriveListBox.ListCount - 1
  127.     If StrComp(Left(DriveListBox.List(i), 1), Left(DriveLetter, 1), 1) = 0 Then
  128.     If Len(DriveListBox.List(i)) = 2 Then
  129.         DriveType = DRIVE_FLOPPY
  130.     ElseIf Mid(DriveListBox.List(i), 3, 2) = "\\" Then
  131.         DriveType = DRIVE_NETWORK
  132.     Else
  133.         
  134.         DriveType = DRIVE_FIXED
  135.     End If
  136.     Exit For
  137.     End If
  138. Next
  139.  
  140. End Function
  141.  
  142. Function ExtensionOnly (ByVal File As String) As String
  143. ' Returns file name extension "BAS"
  144. ' This is a global function that will be overridden
  145. ' by local function ExtensionOnly defined in PROJTEST.FRM
  146. ' So this function is dead
  147.  
  148. Dim Filename As FilenameType
  149. Dim Result As Integer
  150. Result = FileNameSplit(File, Filename)
  151. ExtensionOnly = Filename.Extension
  152.  
  153. End Function
  154.  
  155. Private Function FileNameExpand (Filename As FilenameType) As String
  156. ' Assembles a qualified file name from separate fields
  157.  
  158. Dim Delimiter$
  159. If Len(RTrim$(Filename.drive)) > 2 Then
  160.     If Filename.drive = String$(8, 0) Then
  161.     FileNameExpand$ = ""
  162.     Else
  163.     FileNameExpand$ = RTrim$(Filename.drive)
  164.     End If
  165. Else
  166.     If Right$(RTrim$(Filename.Path), 1) = ":" Or RTrim$(Filename.Path) = "" Or Right$(RTrim$(Filename.Path), 1) = "\" Then
  167.     Else
  168.     Delimiter$ = "\"
  169.     End If
  170.     If Left$(Filename.Path, 2) = RTrim$(Filename.drive) Then
  171.     FileNameExpand$ = UCase$(RTrim$(Filename.Path) + Delimiter$ + RTrim$(Filename.Filename))
  172.     Else
  173.     FileNameExpand$ = UCase$(RTrim$(Filename.drive) + RTrim$(Filename.Path) + Delimiter$ + RTrim$(Filename.Filename))
  174.     End If
  175. End If
  176.  
  177. End Function
  178.  
  179. Function FilenameOnly (ByVal FileSpec As String) As String
  180. ' Returns the file name part of a FileSpec "FILENAME.BAS"
  181.  
  182. Dim File As FilenameType
  183. If FileNameSplit(FileSpec, File) Then
  184.     FilenameOnly = File.Filename
  185. End If
  186.  
  187. End Function
  188.  
  189. Function FileNameSplit (ByVal FilenameString$, Filename As FilenameType) As Integer
  190. ' Splits a file name into separate fields
  191.  
  192. Dim er As Integer
  193. Dim FilNam$
  194. Dim Colon As Integer
  195. Dim NoDrive As Integer
  196. Dim c As Integer
  197.  
  198. FilNam$ = UCase$(FilenameString$)
  199. Filename.drive = ""
  200. Filename.Path = ""
  201. Filename.Filename = ""
  202. Filename.Basename = ""
  203. Filename.Extension = ""
  204. Colon = InStr(FilNam$, ":")
  205. If Colon = 2 Then
  206.     Filename.drive = Left$(FilNam$, 2)
  207. ElseIf Colon Then
  208.     If Len(FilNam$) > Colon Or Colon < 4 Or Colon > 5 Then
  209.     er = True
  210.     Else
  211.     NoDrive = True
  212.     Filename.drive = Left$(FilNam$, Colon)
  213.     End If
  214. End If
  215. If er = 0 And NoDrive = False Then
  216.     For c = Len(FilNam$) To 1 + Len(RTrim$(Filename.drive)) Step -1
  217.     If Mid$(FilNam$, c, 1) = "\" Then
  218.         If c = Len(RTrim$(Filename.drive)) + 1 Then
  219.         Filename.Path = Left$(FilNam$, c)
  220.         Else
  221.         Filename.Path = Left$(FilNam$, c - 1)
  222.         End If
  223.         Exit For
  224.     End If
  225.     Next
  226.     If RTrim$(Mid$(FilNam$, c + 1)) <> ".." Then
  227.     If InStr(Mid$(FilNam$, c + 1), ".") Then
  228.         Filename.Basename = Left$(Left$(Mid$(FilNam$, c + 1), InStr(Mid$(FilNam$, c + 1), ".") - 1), 8)
  229.         Filename.Extension = Mid$(Mid$(FilNam$, c + 1), InStr(Mid$(FilNam$, c + 1), ".") + 1, 3)
  230.     Else
  231.         Filename.Basename = Mid$(FilNam$, c + 1)
  232.     End If
  233.     Else
  234.     Filename.Path = RTrim$(Filename.Path) + ".."
  235.     End If
  236.     If RTrim$(Filename.Basename) = "" And RTrim$(Filename.Extension) <> "" Then
  237.     er = True
  238.     Filename.Extension = ""
  239.     Filename.Path = ""
  240.     Filename.drive = ""
  241.     Else
  242.     If Len(RTrim$(Filename.Extension)) Then
  243.         Filename.Filename = RTrim$(Filename.Basename) + "." + Filename.Extension
  244.     Else
  245.         Filename.Filename = RTrim$(Filename.Basename)
  246.     End If
  247.     If RTrim$(Filename.Filename) = "." Then Filename.Filename = ""
  248.     End If
  249. End If
  250. If er Then
  251.     FileNameSplit% = False
  252. Else
  253.     FileNameSplit% = True
  254. End If
  255.  
  256. End Function
  257.  
  258. Function IsDir (ByVal FileSpec As String) As Integer
  259.  
  260. Dim Result As Integer
  261. On Local Error Resume Next
  262. Result = GetAttr(FileSpec)
  263. If Err = 0 And Result = 16 Then ' ATTR_DIRECTORY= 16
  264.     IsDir = True
  265. End If
  266.  
  267. End Function
  268.  
  269. Function IsFile (ByVal FileSpec As String) As Integer
  270. ' Returns True if a file called Filename exists
  271. ' Filename CAN NOT contain wildcards
  272.  
  273. Dim Result As String
  274. On Local Error Resume Next
  275. Result = Dir(FileSpec)
  276. If Err = 0 And LCase(Result) = LCase(FilenameOnly(FileSpec)) And Result <> "" Then
  277.     IsFile = True
  278. End If
  279.  
  280. End Function
  281.  
  282. Function IsFileSpec (ByVal Filename As String) As Integer
  283. ' Returns True if Filename is
  284. ' a file, a directory or a volume label
  285. ' Filename must not contain any wildcards
  286.  
  287. Dim Result As Integer
  288. On Local Error Resume Next
  289. Result = GetAttr(Filename)
  290. If Err = 0 Then IsFileSpec = True
  291.  
  292. End Function
  293.  
  294. Function MatchesTemplate% (TestText$, Template$)
  295. ' Checks if a file name matches Template ("FILENAME.BAS", "*.BAS")
  296.  
  297. Dim CheckLen As Integer, c As Integer
  298. Dim TChar$, NoMatch As Integer
  299.  
  300. If Len(Template$) > Len(TestText$) Then
  301.     CheckLen = Len(Template$)
  302. Else
  303.     CheckLen = Len(TestText$)
  304. End If
  305. For c = 1 To CheckLen
  306.     TChar$ = Mid$(Template$, c, 1)
  307.     Select Case TChar$
  308.     Case "?"
  309.     Case "*"
  310.         Exit For
  311.     Case Mid$(TestText$, c, 1)
  312.     Case ""
  313.         NoMatch = True
  314.         Exit For
  315.     Case Else
  316.         NoMatch = True
  317.         Exit For
  318.     End Select
  319. Next
  320. If Len(Template$) > Len(TestText$) Then
  321.     If InStr(Template$, "*") = False And Mid$(Template$, Len(TestText$) + 1, Len(Template$) - Len(TestText$)) <> String$(Len(Template$) - Len(TestText$), "?") Then
  322.     NoMatch = True
  323.     End If
  324. End If
  325. If Not NoMatch Then MatchesTemplate = True
  326.  
  327. End Function
  328.  
  329. Function NextDir (Path As String) As String
  330. ' Returns the next directory name in a long Path string
  331. ' NextDir("D:\VB30\LIB\FILENAME.BAS") = "VB30"
  332.  
  333. Dim NewPath As String
  334. If Mid(Path, 2, 1) = ":" Then
  335.     NewPath = Mid(Path, 3)
  336. Else
  337.     NewPath = Path
  338. End If
  339. Select Case InStr(NewPath, "\")
  340.     Case 0
  341.     NextDir = NewPath
  342.     Path = ""
  343.     Case 1
  344.     NextDir = "\"
  345.     Path = Mid(NewPath, 2)
  346.     Case Else
  347.     NextDir = Left(NewPath, InStr(NewPath, "\") - 1)
  348.     Path = Mid(NewPath, InStr(NewPath, "\") + 1)
  349. End Select
  350.  
  351. End Function
  352.  
  353. Private Function PathNameOnly_FromDir (ByVal Directory As String) As String
  354. ' Returns the path name part of a path string
  355. ' PathnameOnly_FromDir("D:\VB30\LIB") = "\VB30\LIB"
  356.  
  357. Dim WholePath As FilenameType
  358. Dim Result As Integer
  359. Result = FileNameSplit(PathNameWithSlash(Directory) + "*.*", WholePath)
  360. If WholePath.drive <> "" Then
  361.     PathNameOnly_FromDir = Mid(WholePath.Path, Len(WholePath.drive) + 1)
  362. Else
  363.     PathNameOnly_FromDir = WholePath.Path
  364. End If
  365.  
  366. End Function
  367.  
  368. Function PathnameWithoutSlash (ByVal FileSpec As String) As String
  369. ' Returns a path name from a filespec without the ending slash
  370. ' The result can be used in ChDir, for example
  371. ' PathnameWithoutSlash("D:\VB30\LIB\FILENAME.BAS") = "D:\VB30\LIB"
  372.  
  373. Dim File As FilenameType
  374. If FileNameSplit(FileSpec, File) Then
  375.     PathnameWithoutSlash = File.Path
  376. End If
  377.  
  378. End Function
  379.  
  380. Function PathNameWithSlash (ByVal Path$) As String
  381. ' Returns a path name without the ending slash
  382. ' The result can be used in building filespecs, for example
  383. ' PathnameWithSlash("D:\VB30\LIB") = "D:\VB30\LIB\"
  384.  
  385. If Right$(RTrim$(Path$), 1) = ":" Or RTrim$(Path$) = "" Or Right$(RTrim$(Path$), 1) = "\" Then
  386.     PathNameWithSlash = Path$
  387. Else
  388.     If IsFile(Path$) Then
  389.     PathNameWithSlash = PathNameWithSlash(AbsPath(Path$, ".."))
  390.     Else
  391.     PathNameWithSlash = Path$ + "\"
  392.     End If
  393. End If
  394.  
  395. End Function
  396.  
  397.